#------------------------------------------------------------------------------#
#
#                 _         _    _      _                _
#                (_)       | |  | |    | |              | |
#   _ __    ___   _  _ __  | |_ | |__  | |  __ _  _ __  | | __
#  | '_ \  / _ \ | || '_ \ | __|| '_ \ | | / _` || '_ \ | |/ /
#  | |_) || (_) || || | | || |_ | |_) || || (_| || | | ||   <
#  | .__/  \___/ |_||_| |_| \__||_.__/ |_| \__,_||_| |_||_|\_\
#  | |
#  |_|
#
#  This file is part of the 'rstudio/pointblank' project.
#
#  Copyright (c) 2017-2025 pointblank authors
#
#  For full copyright and license information, please look at
#  https://rstudio.github.io/pointblank/LICENSE.html
#
#------------------------------------------------------------------------------#


#' Read a **pointblank** YAML file to create an *informant* object
#'
#' @description
#'
#' With `yaml_read_informant()` we can read a **pointblank** YAML file that
#' describes table information (typically generated by the [yaml_write()]
#' function. What's returned is a new *informant* object with the information
#' intact. The *informant* object can be given more information through use of
#' the `info_*()` functions.
#'
#' @param filename *File name*
#'
#'   `scalar<character>` // **required**
#'
#'   The name of the YAML file that contains fields related to an *informant*.
#'
#' @param path *File path*
#'
#'   `scalar<character>` // *default:* `NULL` (`optional`)
#'
#'   An optional path to the YAML file (combined with `filename`).
#'
#' @return A `ptblank_informant` object.
#'
#' @section Examples:
#'
#' There's a YAML file available in the **pointblank** package that's called
#' `"informant-small_table.yml"`. The path for it can be accessed through
#' `system.file()`:
#'
#' ```r
#' yml_file_path <-
#'   system.file(
#'     "yaml", "informant-small_table.yml",
#'     package = "pointblank"
#'   )
#' ```
#'
#' The YAML file can be read as an informant by using the
#' `yaml_read_informant()` function.
#'
#' ```r
#' informant <- yaml_read_informant(filename = yml_file_path)
#'
#' informant
#' ```
#'
#' \if{html}{
#' \out{
#' `r pb_get_image_tag(file = "man_yaml_write_3.png")`
#' }
#' }
#'
#' As can be seen from the information report, the available table metadata was
#' restored and reported. If you expect metadata to change with time, it might
#' be beneficial to use [incorporate()] to query the target table. Or, we can
#' perform this querying directly from the YAML file with
#' [yaml_informant_incorporate()].
#'
#' @family pointblank YAML
#' @section Function ID:
#' 11-3
#'
#' @export
yaml_read_informant <- function(
    filename,
    path = NULL
) {

  if (!is.null(path)) {
    filename <- file.path(path, filename)
  }

  initial_wd <- fs::path_abs(fs::path_wd())
  wd_path <- fs::as_fs_path(dirname(filename))

  if (!fs::dir_exists(wd_path)) {
    stop(
      "The `path` provided (", as.character(wd_path), ") does not exist.",
      call. = FALSE
    )
  }

  if (initial_wd != wd_path) {
    setwd(as.character(wd_path))
    on.exit(setwd(as.character(initial_wd)))
  }

  file_to_read <- basename(filename)

  informant_list <-
    expr_from_informant_yaml(path = file_to_read, incorporate = FALSE)

  informant <-
    informant_list$expr_str %>%
    rlang::parse_expr() %>%
    rlang::eval_tidy()

  informant$metadata <- informant_list$metadata
  informant
}

#' Get an *informant* from **pointblank** YAML and `incorporate()`
#'
#' @description
#'
#' The `yaml_informant_incorporate()` function operates much like the
#' [yaml_read_informant()] function (reading a **pointblank** YAML file and
#' generating an *informant* with all information in place). The key difference
#' is that this function takes things a step further and incorporates aspects
#' from the the target table (defined by table-prep formula that is required in
#' the YAML file). The additional auto-invocation of [incorporate()] uses the
#' default options of that function. As with [yaml_read_informant()] the
#' informant is returned except, this time, it has been updated with the latest
#' information from the target table.
#'
#' @param filename *File name*
#'
#'   `scalar<character>` // **required**
#'
#'   The name of the YAML file that contains fields related to an *informant*.
#'
#' @param path *File path*
#'
#'   `scalar<character>` // *default:* `NULL` (`optional`)
#'
#'   An optional path to the YAML file (combined with `filename`).
#'
#' @return A `ptblank_informant` object.
#'
#' @section Examples:
#'
#' There's a YAML file available in the **pointblank** package that's called
#' `"informant-small_table.yml"`. The path for it can be accessed through
#' `system.file()`:
#'
#' ```r
#' yml_file_path <-
#'   system.file(
#'     "yaml", "informant-small_table.yml",
#'     package = "pointblank"
#'   )
#' ```
#'
#' The YAML file can be read as an informant by using the
#' `yaml_informant_incorporate()` function. If you expect metadata to change
#' with time, it's best to use `yaml_informant_incorporate()` instead of
#' [yaml_read_informant()] since the former will go the extra mile and perform
#' [incorporate()] in addition to the reading.
#'
#' ```r
#' informant <- yaml_informant_incorporate(filename = yml_file_path)
#'
#' informant
#' ```
#'
#' \if{html}{
#' \out{
#' `r pb_get_image_tag(file = "man_yaml_write_3.png")`
#' }
#' }
#'
#' As can be seen from the information report, the available table metadata was
#' restored and reported. If the metadata were to change with time, that would
#' be updated as well.
#'
#' @family pointblank YAML
#' @section Function ID:
#' 11-7
#'
#' @export
yaml_informant_incorporate <- function(
    filename,
    path = NULL
) {

  if (!is.null(path)) {
    filename <- file.path(path, filename)
  }

  informant_list <-
    expr_from_informant_yaml(path = filename)

  informant <-
    informant_list$expr_str %>%
    rlang::parse_expr() %>%
    rlang::eval_tidy()

  informant$metadata <- informant_list$metadata

  informant <- informant %>% incorporate()
  informant
}

expr_from_informant_yaml <- function(path, incorporate = FALSE) {

  # Read the YAML file with `yaml::read_yaml()`
  y <- yaml::read_yaml(file = path)

  # Perform checks on elements of `y`
  check_info_yaml_table(y)
  check_info_yaml_columns(y)
  check_info_yaml_others(y)

  # Backcompatibility with YAML files that have the deprecated `read_fn` key
  if ("read_fn" %in% names(y)) {

    read_fn_idx <- which(names(y) == "read_fn")
    names(y)[read_fn_idx] <- "tbl"
  }

  # Get the `tbl`, `table_name`, `info_label`, `lang`, and `locale`
  # values from the YAML file and create argument strings
  tbl <- paste0("  tbl = ", y$tbl)

  if (!is.null(y$table$name)) {
    tbl_name <- paste0("  tbl_name = \"", y$table$name, "\"")
  } else {
    tbl_name <- NULL
  }

  if (!is.null(y$info_label)) {
    label <- paste0("  label = \"", y$info_label, "\"")
  } else {
    label <- NULL
  }

  if (!is.null(y$lang) && y$lang != "en") {
    lang <- paste0("  lang = \"", y$lang, "\"")
  } else {
    lang <- NULL
  }

  if (!is.null(y$locale) && y$locale != "en") {
    locale <- paste0("  locale = \"", y$locale, "\"")
  } else {
    locale <- NULL
  }

  # Generate `info_snippet()` expressions
  info_snippets <- make_info_snippets(y$meta_snippets)

  # Generate the expression string
  expr_str <-
    paste0(
      "create_informant(\n",
      paste(c(tbl, tbl_name, label, lang, locale), collapse = ",\n"),
      "\n) ",
      info_snippets
    )

  # Add the `incorporate()` statement if needed (this is
  # for the `yaml_informant_incorporate()` function)
  if (incorporate) {
    expr_str <- paste0(expr_str, "%>%\nincorporate()")
  }

  y$tbl <- NULL
  y$read_fn <- NULL
  y$lang <- NULL
  y$locale <- NULL
  y$meta_snippets <- NULL
  y$type <- NULL
  y$tbl_name <- NULL
  y$info_label <- NULL

  list(
    expr_str = expr_str,
    metadata = y
  )
}

check_info_yaml_table <- function(y) {

  # If `table` is present, perform a few validations on that component
  if ("table" %in% names(y)) {

    # Validate that 2nd-level elements have unique names
    if (any(duplicated(names(y[["table"]])))) {

      stop("Duplicate column names provided in `table`.", call. = FALSE)
    }

    # Get component names of `table`
    table_names <- names(y[["table"]])

    # Validate that there are only character vectors inside `table`
    checks <-
      lapply(
        table_names,
        FUN = function(x) {
          x_names <- names(y[["table"]][x])

          for (z in x_names) {
            if (is.list(y[["table"]][[z]])) {

              stop(
                "All subcomponents inside of `table` should be a ",
                "character vector.",
                call. = FALSE
              )
            }
          }
        }
      )
  }
}

check_info_yaml_columns <- function(y) {

  # If `columns` is present, perform a few validations on that component
  if ("columns" %in% names(y)) {

    # Validate that 2nd-level elements have unique names
    if (any(duplicated(names(y[["columns"]])))) {

      stop("Duplicate column names provided in `columns`.", call. = FALSE)
    }

    # Get listed column names
    column_names <- names(y[["columns"]])

    # Validate that there is no more than only a single level below
    # the column names
    checks <-
      lapply(
        column_names,
        FUN = function(x) {
          x_names <- names(y[["columns"]][x])

          for (z in x_names) {

            if (is.list(y[["columns"]][[z]])) {

              components_are_char <-
                unname(unlist(lapply(y[["columns"]][[z]], is.character)))

              if (!all(components_are_char)) {
                stop(
                  "All components inside of `columns/", z,
                  "` should either be text or text under a single heading.",
                  call. = FALSE
                )
              }
            }
          }
        }
      )
  }
}

check_info_yaml_others <- function(y) {

  # If any other items are present, perform a few validations on those
  exclusions <- c("table", "columns", "actions", "steps")
  other_names <- base::setdiff(names(y), exclusions)

  if (length(other_names) > 0) {

    # Validate that there is no more than only a single level below
    # the column names
    checks <-
      lapply(
        other_names,
        FUN = function(x) {

          if (is.list(y[[x]])) {

            if (any(unname(unlist(lapply(y[[x]], Negate(is.character)))))) {

              idx <- which(unname(unlist(lapply(y[[x]], Negate(is.character)))))

              stop(
                "All components inside `", x, "/", names(y[[x]][idx]),
                "` should be a character vector.",
                call. = FALSE
              )
            }

          } else if (!is.list(y[[x]])) {
            if (!is.character(y[[x]])) {

              stop(
                "The component inside `", x, "` should be a character vector.",
                call. = FALSE
              )
            }
          }
        }
      )
  }
}

make_info_snippets <- function(snippets) {

  if (length(snippets) == 0) return("")

  str_exprs <-
    vapply(
      seq_along(snippets),
      FUN.VALUE = character(1),
      USE.NAMES = FALSE,
      FUN = function(x) {

        snippet_name <- names(snippets[x])
        snippet_fun <- snippets[[x]]

        paste0(
          "%>% info_snippet(",
          "snippet_name = \"", snippet_name, "\", ",
          "fn = ", snippet_fun, ")"
        )
      }
    )

  paste(str_exprs, collapse = " ")
}
